#!/usr/bin/perl
#
# Modify a place record
#
use Counter;
use POSIX;
use Counter::CGI;
use Encode;
use CounterCGI;
# Counter specific
use ErrorForm;

require "lib/isemail.pl";

$] > 5.008 && binmode(STDOUT, ":utf8"); # set web page output to utf-8
$prefix = "db";

# Parse the entry
$entry = new Counter::CGI;
warn "Charset of form is ", $entry->charset(), "\n";

$places = FileTable::open("${prefix}/places", O_RDWR|O_CREAT);
$users = FileTable::open("${prefix}/users", O_RDONLY|O_CREAT);

$key = $entry->param("_key");
$rec = $places->get($key);
if (!$rec) {
    errorForm("Record $key not found");
}
$change = 0;
for $field ($entry->param()) {
    next if ($field =~ /^[_*]/);
    my $newval;
    if ($] > 5.008) {
        $newval = Encode::decode("utf-8", $entry->param($field));
    } else {
        $newval = $entry->param($field);
    }
    if (mod($rec, $field, $newval)) {
	#print STDERR "Changed $field to ", $entry->param($field), "\n";
	$changed .= " $field";
	$change = 1;
    }
}
# Special-patching of Within field
if ($rec->{type} eq "world") {
    if (defined($rec->{within})) {
	delete $rec->{within};
	$change = 1;
    }
} elsif ($rec->{within} !~ /^\d+$/) {
    my $tmprec = $places->getbykey("name", $rec->{within});
    if ($tmprec) {
	$rec->{within} = $tmprec->key;
	$changed .= " within(name)";
	$change = 1;
    } else {
	errorForm("Within: No such place as $$rec{within} found");
    }
}
if ($changed =~ / name/) {
    my $xrec = $places->getbykey("name", $rec->{name});
    if ($xrec && $xrec->key != $rec->key) {
	my $otherkey = $xrec->key;
	errorForm("Name already exists on $otherkey: $$rec{name}");
    }
}
$rec->store() if $change;

# Now point the browser back to the original page....
$name = urlname($rec->{name});
print <<EoF;
Content-type: text/html; charset="utf-8"

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">

<html><head>
</head><body>
List of changed fields: $changed
<br>
<a href="place.cgi?$name">Go back to record</a>
</body></html>
EoF


sub mod {
    my ($rec, $field, $val) = @_;
    $val =~ s/\s*$//;
    # strip some boring stuff Web browsers' editors tend to put in
    $val =~ s/\r//g;
    if ($rec->{$field} ne $val) {
	if (length($val) == 0) {
	    delete $rec->{$field};
	} else {
	    $rec->{$field} = $val;
	}
	return 1;
    } else {
	return 0;
    }
}

sub urlname {
# urlify a string
    my $name = shift;
    $name =~ s/\+/%2B/g;
    $name =~ s/ /+/g;
    $name =~ s/\,/%2C/g;
    $name;
}
